home *** CD-ROM | disk | FTP | other *** search
/ Scene 96 / Scene 96 International Edition (Zyklop Software) (Disc 2) (1997).iso / graphics / artpacks / acid0896 / simplexb.pas < prev    next >
Pascal/Delphi Source File  |  1996-05-18  |  17KB  |  502 lines
  1. {$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q+,R+,S+,T-,V-,X+,Y+}
  2. {$M 4096,0,655360}
  3.  
  4. PROGRAM Simple_XB_Viewer;
  5.  
  6. USES  CRT,   { Standard CRT unit }
  7.       STM,   { Streams }
  8.       VGA;   { VGA functions }
  9.  
  10. TYPE  Char4        = ARRAY [0..3] OF Char;
  11.  
  12. Const XB_ID        : Char4 = 'XBIN';
  13.       XBIN_PALETTE = $01;
  14.       XBIN_FONT    = $02;
  15.       XBIN_COMPRESS= $04;
  16.       XBIN_NONBLINK= $08;
  17.       XBIN_512     = $10;
  18.       XBIN_RESERVED= $E0;
  19.  
  20. TYPE  XB_Header    = RECORD
  21.                        ID      : Char4;
  22.                        EofChar : Byte;
  23.                        Width   : Word;
  24.                        Height  : Word;
  25.                        Fontsize: Byte;
  26.                        Flags   : Byte;
  27.                      END;
  28.       LineStart    = ARRAY[0..1023] OF LongInt;
  29.       LineStartPtr = ^LineStart;
  30.  
  31. VAR   XBIN         : Stream;
  32.       XBHdr        : XB_Header;
  33.       Lines        : ARRAY[0..63] OF LineStartPtr; { Offset in File of line start }
  34.       Font         : ARRAY[0..(512*32)-1] OF Byte; { Font Table                   }
  35.       Palette      : ARRAY[0..15,1..3] OF Byte;    { Palette                      }
  36.       FontDepth    : Word;                         { 256 or 512 characters        }
  37.       Count        : Word;
  38.       X, Y         : Word;
  39.       CountByte    : Byte;
  40.       RunLength    : Byte;
  41.       Choice       : Char;
  42.       LineBuf      : ARRAY[1..128] OF BYTE;
  43.  
  44. PROCEDURE Abort (Str: String);
  45. BEGIN
  46.    WriteLn;
  47.    WriteLn('SimpleXB V1.00.  Execution aborted.');
  48.    WriteLn;
  49.    WriteLn(Str);
  50.    WriteLn;
  51.    Halt(1);
  52. END;
  53.  
  54. FUNCTION Strf(Val:Word):String;
  55. VAR Temp : STRING;
  56. BEGIN
  57.    Str(Val,Temp);
  58.    Strf:=Temp;
  59. END;
  60.  
  61. {█ Show palette : Quick & Dirty method ██████████████████████████████████████}
  62. PROCEDURE ShowPalette;
  63. Const BW_Pal : Array[1..6] of Byte = (0,0,0,63,63,63);
  64. VAR Count : Word;
  65.     X, Y  : Word;
  66.     Col   : Word;
  67.     Row   : Word;
  68.     WMode : Boolean;
  69. BEGIN
  70.   WMode:=DirectVideo;                  { Save DirectVideo status }
  71.   DirectVideo:=FALSE;                  { Set it to false         }
  72.   VGA_Mode($13);                       { Set mode 320*200 256 colors }
  73.   { Color setup for showing the palette          }
  74.   {   0 : remains black                          }
  75.   {   1 : white                                  }
  76.   {   2-17 : Palette from XBIN                   }
  77.   VGA_SetPalette(0,2,BW_Pal);
  78.   VGA_SetPalette(2,16,Palette);
  79.  
  80.   TextColor(1);
  81.   TextBackGround(0);
  82.   WriteLn; WriteLn;
  83.   WriteLn('              XBIN PALETTE');
  84.   WriteLn('             --------------');
  85.   WriteLn;
  86.   WriteLn('  0    1    2    3    4    5    6    7');
  87.   WriteLn; WriteLn; WriteLn; WriteLn; WriteLn; WriteLn;
  88.   WriteLn('  8    9    10   11   12   13   14   15');
  89.  
  90.   FOR Count:=0 TO 15 DO BEGIN
  91.      Col:=Count MOD 8;
  92.      Row:=Count DIV 8;
  93.      { Draw box }
  94.      FOR X:=0 TO 31 DO BEGIN
  95.         MEM[SegA000:(49+Row*56)*320+(X+Col*40)+4] := 1;
  96.         MEM[SegA000:(80+Row*56)*320+(X+Col*40)+4] := 1;
  97.      END;
  98.      FOR Y:=0 TO 31 DO BEGIN
  99.         MEM[SegA000:(49+Y+Row*56)*320+(Col*40)+ 4] := 1;
  100.         MEM[SegA000:(49+Y+Row*56)*320+(Col*40)+35] := 1;
  101.      END;
  102.      FOR X:=1 TO 30 DO BEGIN
  103.         FOR Y:=1 to 30 DO BEGIN
  104.            MEM[SegA000:(49+Y+Row*56)*320+(X+Col*40)+4] := Count+2;
  105.            MEM[SegA000:(49+Y+Row*56)*320+(X+Col*40)+4] := Count+2;
  106.         END;
  107.      END;
  108.   END;
  109.  
  110.   IF (ReadKey=#0) THEN
  111.      ReadKey;
  112.  
  113.   TextMode(Co80);
  114.   DirectVideo:=WMode;                  { Restore orriginal DirectVideo }
  115. END;
  116.  
  117.  
  118. {█ Show font : Quick & Dirty method █████████████████████████████████████████}
  119. PROCEDURE ShowFont;
  120. VAR Count : Word;
  121.     Y     : Word;
  122.     Block : Word;
  123.     Col   : Word;
  124.     Row   : Word;
  125.     WMode : Boolean;
  126.     Part  : Word;
  127. BEGIN
  128.   WMode:=DirectVideo;                  { Save DirectVideo status }
  129.   DirectVideo:=FALSE;                  { Set it to false         }
  130.   VGA_Mode($12);                       { Set mode 640*480 16 colors }
  131.  
  132.   Part:=0;
  133.  
  134.   REPEAT
  135.      WriteLn('                               XBIN Font (Part ',Part+1,')');
  136.      WriteLn('                              --------------------');
  137.      WriteLn;
  138.      WriteLn('    x> 0 1 2 3 4 5 6 7 8 9 A B C D E F    x> 0 1 2 3 4 5 6 7 8 9 A B C D E F');
  139.      WriteLn('    0x','8x':38); WriteLn;
  140.      WriteLn('    1x','9x':38); WriteLn;
  141.      WriteLn('    2x','Ax':38); WriteLn;
  142.      WriteLn('    3x','Bx':38); WriteLn;
  143.      WriteLn('    4x','Cx':38); WriteLn;
  144.      WriteLn('    5x','Dx':38); WriteLn;
  145.      WriteLn('    6x','Ex':38); WriteLn;
  146.      WriteLn('    7x','Fx':38); WriteLn;
  147.  
  148.      For Count:=0 to 255 DO BEGIN
  149.         Row  :=(Count MOD 128) DIV 16;
  150.         Col  :=(Count MOD 128) MOD 16;
  151.         Block:=Count DIV 128;
  152.         FOR Y:=0 TO XBHdr.FontSize-1 DO
  153.           MEM[SegA000:((Row*32)+64+Y)*80+Col*2+38*Block+7]:=
  154.           Font[(Part*256+Count)*XBHdr.FontSize+Y];
  155.      END;
  156.  
  157.      Inc(Part);
  158.      IF (XBHdr.Flags AND XBIN_512) = 0 THEN Inc(Part); { Set Part to 2 if 256 characters }
  159.   UNTIL Part=2;
  160.  
  161.   IF (ReadKey=#0) THEN
  162.      ReadKey;
  163.  
  164.   TextMode(Co80);
  165.   DirectVideo:=WMode;                  { Restore original DirectVideo }
  166. END;
  167.  
  168. {█ Show Image ███████████████████████████████████████████████████████████████}
  169. PROCEDURE ShowImage(DispHeight : WORD);
  170. TYPE VideoWord = RECORD
  171.                    Case Boolean of
  172.                    True : (Character:Byte; Attribute:Byte);
  173.                    False: (CharAttr :Word);
  174.                  END;
  175. VAR  TopX : WORD;
  176.      TopY : WORD;
  177.      X,Y  : WORD;
  178.      Len  : WORD;
  179.      CH   : Char;
  180.      VidW : VideoWord;
  181.      Count: BYTE;
  182. BEGIN
  183.   GotoXY(1,1);
  184.  
  185.   TopX:=0;
  186.   TopY:=0;
  187.  
  188.   IF (XBHdr.Width<80) THEN
  189.      Len:=XBHdr.Width
  190.   ELSE
  191.      Len:=80;
  192.  
  193.   IF XBHdr.Height<DispHeight THEN
  194.      DispHeight:=XBHdr.Height;
  195.   REPEAT
  196.      FOR Y:=0 TO DispHeight-1 DO BEGIN
  197.         IF (XBHdr.Flags AND XBIN_COMPRESS) <> 0 THEN BEGIN
  198.            STM_Goto(XBIN,Lines[(Y+TopY) DIV 1024]^[(Y+TopY) MOD 1024]);
  199.            IF (XBIN.LastErr<>STM_OK) THEN BEGIN
  200.               TextMode(Co80);
  201.               Abort('Error reading XBIN.');
  202.            END;
  203.  
  204.            X:=0;
  205.            WHILE X<TopX+Len DO BEGIN
  206.               STM_Read(XBIN,Countbyte,1);
  207.               IF (XBIN.LastErr<>STM_OK) THEN BEGIN
  208.                  TextMode(Co80);
  209.                  Abort('Invalid XBIN.  Out of data.');
  210.               END;
  211.  
  212.               RunLength := (CountByte AND $3F) + 1;
  213.               CASE (CountByte AND $C0) OF
  214.                  $00 : STM_Read(XBIN,LineBuf,RunLength*2);
  215.                  $40 : STM_Read(XBIN,LineBuf,1+RunLength);
  216.                  $80 : STM_Read(XBIN,LineBuf,1+RunLength);
  217.                  $C0 : STM_Read(XBIN,LineBuf,2);
  218.               END;
  219.               IF (XBin.lastErr<>STM_OK) THEN BEGIN
  220.                  TextMode(Co80);
  221.                  Abort('Invalid XBIN.  Out of data.');
  222.               END;
  223.  
  224.               FOR Count:=1 TO RunLength DO BEGIN
  225.                  CASE (CountByte AND $C0) OF
  226.                     $00 : BEGIN
  227.                             VidW.Character:=LineBuf[Count*2-1];
  228.                             VidW.Attribute:=LineBuf[Count*2];
  229.                           END;
  230.                     $40 : BEGIN
  231.                             VidW.Character:=LineBuf[1];
  232.                             VidW.Attribute:=LineBuf[Count+1];
  233.                           END;
  234.                     $80 : BEGIN
  235.                             VidW.Character:=LineBuf[Count+1];
  236.                             VidW.Attribute:=LineBuf[1];
  237.                           END;
  238.                     $C0 : BEGIN
  239.                             VidW.Character:=LineBuf[1];
  240.                             VidW.Attribute:=LineBuf[2];
  241.                           END;
  242.                  END;
  243.                  IF (X>=TopX) AND (X<TopX+Len) THEN
  244.                     MemW[SegB800:Y*160+(X-TopX)*2]:=VidW.CharAttr;
  245.  
  246.                  Inc(X);
  247.                  Dec(RunLength);
  248.               END;
  249.            END;
  250.         END
  251.         ELSE BEGIN  { ==== DISPLAY UNCOMPRESSED XBIN DATA ===== }
  252.            STM_Goto(XBIN,Lines[(Y+TopY) DIV 1024]^[(Y+TopY) MOD 1024]+(TopX*2));
  253.            IF (XBIN.LastErr<>STM_OK) THEN BEGIN
  254.               TextMode(Co80);
  255.               Abort('Error reading XBIN.');
  256.            END;
  257.            STM_Read(XBIN,MEM[SegB800:Y*160],Len*2);
  258.            IF (XBIN.LastErr<>STM_OK) THEN BEGIN
  259.               TextMode(Co80);
  260.               Abort('Error reading XBIN.');
  261.            END;
  262.         END;
  263.      END;
  264.  
  265.      CH:=ReadKey;
  266.      IF CH=#0 THEN BEGIN
  267.         CH:=ReadKey;
  268.         CASE Ch OF
  269.            #72 : IF TopY>0 THEN Dec(TopY);  { Up key }
  270.            #80 : IF TopY<XBHdr.Height-DispHeight THEN Inc(TopY);  { Down key }
  271.            #75 : IF TopX>0 THEN Dec(TopX); { Left key }
  272.            #77 : IF TopX<XBHdr.Width-80 THEN Inc(TopX); { Right key }
  273.         END;
  274.      END;
  275.   UNTIL CH=#27;
  276. END;
  277.  
  278.  
  279. BEGIN
  280.   CheckBreak:=True;
  281.   DirectVideo:=False;
  282.   TextMode(Co80);
  283.  
  284.   WriteLn ('SimpleXB V1.00.  Simple eXtended BIN format viewer');
  285.   WriteLn ('Coded by Tasmaniac / ACiD.');
  286.   WriteLn ('Sourcecode placed into the public domain, use freely');
  287.   WriteLn;
  288.  
  289.   { --- Check for presence of a VGA card --- }
  290.   IF (NOT VGA_IsPresent) THEN
  291.      Abort('VGA required');
  292.  
  293.   { --- Check if sufficient memory is available and allocate Lines --- }
  294.   WriteLn('Allocating memory...');
  295.   FOR Count:=Low(Lines) TO High(Lines) DO BEGIN
  296.      IF MaxAvail<Sizeof(Lines[Count]^) THEN
  297.        Abort('Insuficient memory');
  298.      New(Lines[Count]);
  299.   END;
  300.  
  301.   { --- Check passed parameter and open XB file -------------------------- }
  302.   IF (ParamCount<>1) THEN Abort('SimpleXB Filename');
  303.  
  304.   WriteLn('Opening XBIN ('+ParamStr(1)+')...');
  305.   STM_Open(XBIN,ParamStr(1),NOCREATE);
  306.   IF (XBIN.LastErr<>STM_OK) THEN Abort('Error opening XBIN file '+ParamStr(1));
  307.  
  308.   { --- Read XBIN Header ------------------------------------------------- }
  309.   WriteLn('Reading XBIN Header...');
  310.   STM_Read(XBIN,XBHdr,Sizeof(XBHdr));
  311.   IF (XBIN.LastErr<>STM_OK) THEN Abort('Error reading XBIN Header.');
  312.  
  313.   { --- ID bytes check out ? --------------------------------------------- }
  314.   IF (XBHdr.ID<>XB_ID) OR
  315.      (XBHdr.EofChar<>26) THEN Abort('File is not an eXtended BIN');
  316.   WriteLn('   Image width  : ',XBHdr.Width);
  317.   WriteLn('   Image height : ',XBHdr.Height);
  318.   { IF Width=0 then Height must be 0 too. and vice versa }
  319.   IF ((XBHdr.Width =0) AND (XBHdr.Height<>0) OR
  320.       (XBHdr.Width<>0) AND (XBHdr.Height =0)) THEN
  321.      Abort('Invalid XBIN.  <Width> and <Height> must both be equal or different from 0');
  322.  
  323.   Write  ('   Palette      : ');
  324.   IF (XBHdr.Flags AND XBIN_PALETTE) <> 0 THEN
  325.      WriteLn('Alternate palette present')
  326.   ELSE
  327.      WriteLn('Default palette');
  328.  
  329.   IF XBHdr.Flags AND XBIN_512 <> 0 THEN
  330.      FontDepth:=512
  331.   ELSE
  332.      FontDepth:=256;
  333.  
  334.   Write  ('   Font set     : ');
  335.   IF (XBHdr.Flags AND XBIN_FONT) <> 0 THEN BEGIN
  336.      WriteLn('Alternate font, ',FontDepth,' characters.');
  337.      WriteLn('   Fontsize     : ',XBHdr.Fontsize);
  338.   END
  339.   ELSE BEGIN
  340.      WriteLn('Default font, ',FontDepth,' characters');
  341.      WriteLn('   Fontsize     : ',XBHdr.FontSize,' (Default font)');
  342.  
  343.      IF XBHdr.Fontsize<>16 THEN Abort('Invalid XBIN.  Default <Fontsize> should be 16.');
  344.      IF FontDepth<>256 THEN Abort('Invalid XBIN.  Default font must have 256 characters.');
  345.   END;
  346.   IF (XBHdr.FontSize=0) OR (XBHdr.FontSize>32) THEN
  347.      Abort('Invalid XBIN.  <Fontsize> must be between 1 and 32.');
  348.  
  349.   Write  ('   Compression  : ');
  350.   IF (XBHdr.Flags AND XBIN_COMPRESS) <> 0 THEN
  351.      WriteLn('XBIN Compressed')
  352.   ELSE
  353.      WriteLn('Uncompressed BIN');
  354.  
  355.   Write  ('   Blinking     : ');
  356.   IF (XBHdr.Flags AND XBIN_NONBLINK) <> 0 THEN
  357.      WriteLn('Disabled')
  358.   ELSE
  359.      WriteLn('Enabled');
  360.  
  361.   IF (XBHdr.Flags AND XBIN_RESERVED) <> 0 THEN
  362.      WriteLn('Invalid XBIN.  Reserved <Flags> must be zero.');
  363.  
  364.   { --- IF a Palette is present, read it --------------------------------- }
  365.   IF (XBHdr.Flags AND XBIN_PALETTE <> 0) THEN BEGIN
  366.      WriteLn('Reading palette...');
  367.      STM_Read(XBIN,Palette,Sizeof(Palette));
  368.      IF (XBIN.LastErr<>STM_OK) THEN
  369.         Abort('Error reading XBIN palette.');
  370.      FOR Count:=Low(Palette) TO High(Palette) DO BEGIN
  371.         IF Palette[Count][1]>63 THEN
  372.            Abort('Invalid palette value for color '+Strf(Count)+' RED');
  373.         IF Palette[Count][2]>63 THEN
  374.            Abort('Invalid palette value for color '+Strf(Count)+' GREEN');
  375.         IF Palette[Count][3]>63 THEN
  376.            Abort('Invalid palette value for color '+Strf(Count)+' BLUE');
  377.      END;
  378.   END;
  379.  
  380.   { --- IF a font is present, read it ------------------------------------ }
  381.   IF (XBHdr.Flags AND XBIN_FONT <> 0) THEN BEGIN
  382.      WriteLn('Reading font...');
  383.      STM_Read(XBIN,Font,FontDepth*XBHdr.Fontsize);
  384.      IF (XBIN.LastErr<>STM_OK) THEN
  385.         Abort('Error reading XBIN font.');
  386.   END;
  387.  
  388.   { --- Check Image data & mode ------------------------------------------ }
  389.   IF (XBHdr.Width>0) THEN BEGIN
  390.      IF (XBHdr.Flags AND XBIN_COMPRESS) <> 0 THEN BEGIN
  391.         WriteLn('Checking and preparing XBIN compressed image data...');
  392.  
  393.         Y:=0;
  394.         WHILE Y<XBHdr.Height DO BEGIN
  395.            Write(#13,' Checking line ',Y+1);
  396.            Lines[Y DIV 1024]^[Y MOD 1024]:=STM_GetPos(XBin);
  397.            X:=0;
  398.            WHILE X<XBHdr.Width DO BEGIN
  399.               STM_Read(XBIN,Countbyte,1);
  400.               IF (XBIN.LastErr<>STM_OK) THEN
  401.                  Abort('Invalid XBIN.  Out of data.');
  402.  
  403.               RunLength := (CountByte AND $3F) + 1;
  404.               Inc(X,RunLength);
  405.               CASE (CountByte AND $C0) OF
  406.                  $00 : STM_Read(XBIN,LineBuf,RunLength*2);
  407.                  $40 : STM_Read(XBIN,LineBuf,1+RunLength);
  408.                  $80 : STM_Read(XBIN,LineBuf,1+RunLength);
  409.                  $C0 : STM_Read(XBIN,LineBuf,2);
  410.               END;
  411.               IF (XBin.lastErr<>STM_OK) THEN
  412.                  Abort('Invalid XBIN.  Out of data.');
  413.            END;
  414.  
  415.            IF (X>XBHdr.Width) THEN
  416.               Abort('Invalid XBIN.  Compressed across line boundary.');
  417.  
  418.            Inc(Y);
  419.         END;
  420.         Write(#13,'':79,#13);
  421.  
  422.      END
  423.      ELSE BEGIN
  424.         WriteLn('Checking and preparing uncompressed image data...');
  425.         IF STM_GetSize(XBIN)<STM_GetPos(XBIN)+(XBHdr.Width*XBHdr.Height*2) THEN
  426.            Abort('Invalid XBIN.  Insufficient image data');
  427.         FOR Count:=0 to XBHdr.Height-1 DO
  428.            Lines[Count DIV 1024]^[Count MOD 1024]:=STM_GetPos(XBIN)+(Count*XBHdr.Width*2);
  429.      END;
  430.   END;
  431.   WriteLn('───────────────────────────────────────────────────────────────────────────────');
  432.   WriteLn('XBIN checks out ok...');
  433.   WriteLn('───────────────────────────────────────────────────────────────────────────────');
  434.   WriteLn;
  435.  
  436.   { --- Ask user what to do next ----------------------------------------- }
  437.   REPEAT
  438.      Write('Display: <P>alette, <F>ont, <I>magedata, <X>BIN, All other keys quit : ');
  439.      Choice:=Upcase(Readkey);
  440.      WriteLn(Choice);
  441.      IF Choice=#0 THEN BEGIN  { Function key was pressed }
  442.         Choice:=Readkey;      { Process the next scancode }
  443.         Choice:=#27;          { All others keys quit... }
  444.      END;
  445.  
  446.      CASE (Choice) OF
  447.         'P' : BEGIN
  448.                  IF (XBHdr.Flags AND XBIN_PALETTE) <> 0 THEN
  449.                     ShowPalette
  450.                  ELSE
  451.                     WriteLn('Default palette applies');
  452.               END;
  453.         'F' : BEGIN 
  454.                  IF (XBHdr.Flags AND XBIN_FONT) <> 0 THEN
  455.                     ShowFont
  456.                  ELSE
  457.                     WriteLn('Default palette applies');
  458.               END;
  459.         'I' : BEGIN
  460.                  ShowImage(25);
  461.                  TextMode(Co80);
  462.               END;
  463.         'X' : BEGIN
  464.                 VGA_Set8PixelFont; { This'll look better }
  465.  
  466.                 IF (XBHdr.Flags AND XBIN_PALETTE) <> 0 THEN BEGIN
  467.                    VGA_SetFlatTextPal;
  468.                    VGA_SetPalette(0,16,Palette);
  469.                 END;
  470.  
  471.                 IF (XBHdr.Flags AND XBIN_NONBLINK) <> 0 THEN
  472.                    VGA_SetBlink(FALSE);
  473.  
  474.                 IF (XBHdr.Flags AND XBIN_512) <> 0 THEN
  475.                    VGA_SetActiveFont(0,4); { Activate Character map 0 and 4 }
  476.                                            { 0 and 4 are adjacent Character }
  477.                                            { maps                           }
  478.  
  479.                 VGA_SetFontSize(XBHdr.FontSize);
  480.                 IF (XBHDR.Flags AND XBIN_FONT) <> 0 THEN
  481.                    VGA_SetFont(0,FontDepth,XBHdr.FontSize,0,Font);
  482.  
  483.                 ShowImage(400 DIV XBHdr.FontSize); { 400 Scanlines are on screen }
  484.                 TextMode(Co80);
  485.               END;
  486.         ELSE Choice:=#27;
  487.      END;
  488.   UNTIL (Choice=#27);
  489.  
  490.  
  491.   { --- Free allocated memory -------------------------------------------- }
  492.   WriteLn('Closing XBIN...');
  493.   STM_Close (XBIN);
  494.  
  495.   { --- Free allocated memory -------------------------------------------- }
  496.   WriteLn('Freeing memory...');
  497.   FOR Count:=Low(Lines) TO High(Lines) DO BEGIN
  498.      Dispose(Lines[Count]);
  499.   END;
  500. END.
  501.  
  502.